SWAGOLX.EXE (c) 1993 GDSOFT ALL RIGHTS RESERVED 00003 1 05-25-9408:19ALL ALAN GRAFF Moonphase Algorithm? SWAG9405 17 ╬N {πAs Robert Forbes said to All on 25 Apr 94...ππ RF> Anyone have any idea how to make an algorithm toπ RF> calculate the moonphase given the date?ππHere ya go:ππTYPE DATETYPE = recordπ day:WORD;π MONTH:WORD;π YEAR:WORD;π dow:word;π end;ππ{=================================================================}ππProcedure GregorianToJulianDN(Year, Month, Day:Integer;π var JulianDN :LongInt);πvarπ Century,π XYear : LongInt;ππbegin {GregorianToJulianDN}π If Month <= 2 then beginπ Year := pred(Year);π Month := Month + 12;π end;π Month := Month - 3;π Century := Year div 100;π XYear := Year mod 100;π Century := (Century * D1) shr 2;π XYear := (XYear * D0) shr 2;π JulianDN := ((((Month * 153) + 2) div 5) + Day) + D2π + XYear + Century;π end; {GregorianToJulianDN}ππ{=================================================================}ππFunction MoonPhase(Date:Datetype):Real;ππ (***************************************************************)π (* *)π (* Determines APPROXIMATE phase of the moon (percentage lit) *)π (* 0.00 = New moon, 1.00 = Full moon *)π (* Due to rounding, full values may possibly never be reached *)π (* Valid from Oct. 15, 1582 to Feb. 28, 4000 *)π (* Calculations and BASIC program found in *)π (* "119 Practical Programs For The TRS-80 Pocket Computer" by *)π (* John Clark Craig, TAB Books, 1982 *)π (* Conversion to Turbo Pascal by Alan Graff, Wheelersburg, OH *)π (* *)π (***************************************************************)ππvarπj:longint; m:real;ππBeginπ GregorianToJulianDN(Date.Year,Date.Month,Date.Day,J);π M:=(J+4.867)/ 29.53058;π M:=2*(M-Int(m))-1;π MoonPhase:=Abs(M);πend;ππ 2 05-26-9406:19ALL FRED JOHNSON Day Of Week SWAG9405 9 ╬N {Returns a string or an integer, what ever you want}π{You fix for leap year}ππunit dow;πinterfaceππconstπ saDayOfWeek : array [0..6] of string =π ('Monday','Tuesday','Wednesday','Thursday',π 'Friday','Saturday','Sunday');ππtypeπ spString = ^string;ππfunction IntDow(yyyy,mm,dd : integer) : integer;πfunction StrDow(yyyy,mm,dd : integer) : spString;ππimplementationπ πfunction IntDow(yyyy,mm,dd : integer) : integer;π varπ iAddVal : shortint;π beginπ if mm < 3 then iAddVal := 1 else iAddVal := 0;π IntDow := (((3*(yyyy)-(7*((yyyy)+((mm)+9) div 12)) π div 4+(23*(mm)) div 9+(dd)+2 π +(((yyyy)-iAddVal) div 100+1)*3 div 4-16) mod 7));π end;ππfunction StrDow(yyyy,mm,dd : integer): spString;π var π sReturnString : string;π beginπ sReturnString := saDayOfWeek[IntDow(yyyy, mm, dd)];π StrDow := @sReturnString;π end; πend.π{test file}ππuses dow;πbeginπ write(StrDow(1995, 10,08)^);πend.π 3 05-26-9410:57ALL CHARLES CHAPMAN General Date Routines SWAG9405 195 ╬N {$F+,O+,N+}πUNIT Dates;ππ { Version 1R0 - 1991 03 25 }π { 1R1 - 1991 04 09 - corrected several bugs, and }π { - deleted <JulianDa2>, <Da2OfWeek> and }π { <JulianDa2ToDate> - all found to be not }π { completely reliable. }ππINTERFACEππ { These routines all assume that the year (y, y1) value is supplied in a }π { form that includes the century (i.e., in YYYY form). No checking is }π { performed to ensure that a month (m, m1) value is in the range 1..12 }π { or that a day (d, d1) value is in the range 1..28,29,30,31. The }π { FUNCTION ValidDate may be used to check for valid month and day }π { parameters. FUNCTION DayOfYearToDate returns month and day (m, d) both }π { = 0 if the day-of-the-year (nd) is > 366 for a leap-year or > 365 for }π { other years. }ππ { NOTE: As written, FUNCTION Secs100 requires the presence of a 80x87 }π { co-processor. Its declaration and implementation may be altered to }π { REAL to make use of the floating-point emulation. }ππ { Because the Gregorian calendar was not implemented in all countries at }π { the same time, these routines are not guaranteed to be valid for all }π { dates. The real utility of these routines is that they will not fail }π { on December 31, 1999 - as will many algorithms used in MIS programs }π { implemented on mainframes. } ππ { The routines are NOT highly optimized - I have tried to maintain the }π { style of the algorithms presented in the sources I indicate. Any }π { suggestions for algorithmic or code improvements will be gratefully }π { accepted. This implementation is in the public domain - no copyright }π { is claimed. No warranty either express or implied is given as to the }π { correctness of the algorithms or their implementation. }ππ { Author: Charles B. Chapman, London, Ontario, Canada [74370,516] }π { Thanks to Leonard Erickson who supplied a test suite of values. }ππ FUNCTION IsLeap (y : WORD) : BOOLEAN;ππ FUNCTION ValidDate (y, m, d : WORD) : BOOLEAN;π FUNCTION ValidDate_Str (Str : string; {DWH}π VAR Y, M, D : word;π VAR Err_Str : string) : boolean;π FUNCTION ValidTime_Str (Str : string; {DWH}π VAR H, M, S : word;π VAR Err_Str : string) : boolean;ππ FUNCTION DayOfYear (y, m, d : WORD) : WORD;π FUNCTION JulianDay (y, m, d : WORD) : LONGINT;π FUNCTION JJ_JulianDay (y, m, d : word) : LONGINT; {DWH}ππ FUNCTION DayOfWeek (y, m, d : WORD) : WORD;π FUNCTION DayOfWeek_Str (y, m, d : WORD) : String; {DWH}ππ FUNCTION TimeStr (h, m, s, c : WORD) : STRING;π FUNCTION TimeStr2 (h, m, s : WORD) : STRING;π FUNCTION SIDateStr (y, m, d : WORD; SLen : BYTE; FillCh : CHAR) : STRING;π FUNCTION MDYR_Str (y, m, d : WORD): STRING; {DWH}ππ FUNCTION Secs100 (h, m, s, c : WORD) : DOUBLE;π PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);ππ PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);π PROCEDURE JJ_JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD); {DWH}ππ PROCEDURE DateOfEaster (Yr : WORD; VAR Mo, Da : WORD);π PROCEDURE AddDays (y, m, d : WORD; plus : LONGINT; VAR y1, m1, d1 : WORD);ππ FUNCTION Lotus_Date_Str (nd : LONGINT) : string; {DWH}π FUNCTION Str_Date_to_Lotus_Date_Formatπ (Date : String;π VAR Err_Msg : String): LongInt; {OLC}π{==========================================================================}ππIMPLEMENTATIONπ USESπ Dos;ππ{==========================================================================}ππ FUNCTION IsLeap (y : WORD) : BOOLEAN;ππ { Returns TRUE if <y> is a leap-year }ππ BEGINπ IF y MOD 4 <> 0 THENπ IsLeap := FALSEπ ELSEπ IF y MOD 100 = 0 THENπ IF y MOD 400 = 0 THENπ IsLeap := TRUEπ ELSEπ IsLeap := FALSEπ ELSEπ IsLeap := TRUEπ END; { IsLeap }ππ{==========================================================================}ππ FUNCTION DayOfYear (y, m, d : WORD) : WORD;ππ { function IDAY from remark on CACM Algorithm 398 }π { Computes day of the year for a given calendar date }π { GIVEN: y - year }π { m - month }π { d - day }π { RETURNS: day-of-the-year (1..366, given valid input) }ππ VARπ yy, mm, dd, Tmp1 : LONGINT;π BEGINπ yy := y;π mm := m;π dd := d;π Tmp1 := (mm + 10) DIV 13;π DayOfYear := 3055 * (mm + 2) DIV 100 - Tmp1 * 2 - 91 +π (1 - (yy - yy DIV 4 * 4 + 3) DIV 4 +π (yy - yy DIV 100 * 100 + 99) DIV 100 -π (yy - yy DIV 400 * 400 + 399) DIV 400) * Tmp1 + ddπ END; { DayOfYear }ππ{==========================================================================}ππ FUNCTION JulianDay (y, m, d : WORD) : LONGINT;ππ { procedure JDAY from CACM Alorithm 199 }π { Computes Julian day number for any Gregorian Calendar date }π { GIVEN: y - year }π { m - month }π { d - day }π { RETURNS: Julian day number (astronomically, for the day }π { beginning at noon) on the given date. }ππ VARπ Tmp1, Tmp2, Tmp3, Tmp4, Tmp5 : LONGINT;π BEGINπ IF m > 2 THENπ BEGINπ Tmp1 := m - 3;π Tmp2 := yπ ENDπ ELSEπ BEGINπ Tmp1 := m + 9;π Tmp2 := y - 1π END;π Tmp3 := Tmp2 DIV 100;π Tmp4 := Tmp2 MOD 100;π Tmp5 := d;π JulianDay := (146097 * Tmp3) DIV 4 + (1461 * Tmp4) DIV 4 +π (153 * Tmp1 + 2) DIV 5 + Tmp5 + 1721119π END; { JulianDay }ππ{==========================================================================}π π PROCEDURE DayOfYearToDate (nd, y : WORD; VAR m, d : WORD);π π { procedure CALENDAR from CACM Algorithm 398 }π { Computes month and day from given year and day of the year }π { GIVEN: nd - day-of-the-year (1..366) }π { y - year }π { RETURNS: m - month }π { d - day }ππ VARπ Tmp1, Tmp2, Tmp3, Tmp4, DaYr : LONGINT; π BEGINπ DaYr := nd;π IF (DaYr = 366) AND (DayOfYear (y, 12, 31) <> 366) THENπ DaYr := 999;π IF DaYr <= 366 THENπ BEGINπ IF y MOD 4 = 0 THENπ Tmp1 := 1π ELSEπ Tmp1 := 0;π IF (y MOD 400 = 0) OR (y MOD 100 <> 0) THENπ Tmp2 := Tmp1π ELSEπ Tmp2 := 0;π Tmp1 := 0;π IF DaYr > Tmp2 + 59 THENπ Tmp1 := 2 - Tmp2;π Tmp3 := DaYr + Tmp1;π Tmp4 := ((Tmp3 + 91) * 100) DIV 3055;π d := ((Tmp3 + 91) - (Tmp4 * 3055) DIV 100);π m := (Tmp4 - 2)π ENDπ ELSEπ BEGINπ d := 0;π m := 0π ENDπ END; { DayOfYearToDate }ππ{==========================================================================}ππ PROCEDURE JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);ππ { procedure JDATE from CACM Algorithm 199 }π { Computes calendar date from a given Julian day number for any }π { valid Gregorian calendar date }π { GIVEN: nd - Julian day number (2440000 --> 1968 5 23) }π { RETURNS: y - year }π { m - month }π { d - day }ππ VARπ Tmp1, Tmp2, Tmp3 : LONGINT;π BEGINπ Tmp1 := nd - 1721119;π Tmp3 := (4 * Tmp1 - 1) DIV 146097;π Tmp1 := (4 * Tmp1 - 1) MOD 146097;π Tmp2 := Tmp1 DIV 4;π Tmp1 := (4 * Tmp2 + 3) DIV 1461;π Tmp2 := (4 * Tmp2 + 3) MOD 1461;π Tmp2 := (Tmp2 + 4) DIV 4;π m := ((5 * Tmp2 - 3) DIV 153);π Tmp2 := (5 * Tmp2 - 3) MOD 153;π d := ((Tmp2 + 5) DIV 5);π y := (100 * Tmp3 + Tmp1);π IF m < 10 THENπ m := m + 3π ELSEπ BEGINπ m := m - 9;π y := y + 1π ENDπ END; { JulianDayToDate }ππ{==========================================================================}ππ PROCEDURE DateOfEaster (Yr : WORD; VAR Mo, Da : WORD);ππ { Algorithm "E" from Knuth's "Art of Computer Programming", vol. 1 }π { Computes date of Easter for any year in the Gregorian calendar }π { The local variables are the variable names used by Knuth. }π { GIVEN: Yr - year }π { RETURNS: Mo - month of Easter (3 or 4) }π { Da - day of Easter }ππ VARπ G, C, X, Z, D, E, N : LONGINT;π BEGINπ { Golden number of the year in Metonic cycle }π G := Yr MOD 19 + 1;π { Century }π C := Yr DIV 100 + 1;π { Corrections: }π { <X> is the no. of years in which leap-year was dropped in }π { order to keep step with the sun }π { <Z> is a special correction to synchronize Easter with the }π { moon's orbit . }π X := (3 * C) DIV 4 - 12;π Z := (8 * C + 5) DIV 25 - 5;π { <D> Find Sunday }π D := (5 * Yr) DIV 4 - X - 10;π { Set Epact }π E := (11 * G + 20 + Z - X) MOD 30;π IF E < 0 THENπ E := E + 30;π IF ((E = 25) AND (G > 11)) OR (E = 24) THENπ E := E + 1;π { Find full moon - the Nth of MARCH is a "calendar" full moon }π N := 44 - E;π IF N < 21 THENπ N := N + 30;π { Advance to Sunday }π N := N + 7 - ((D + N) MOD 7);π { Get Month and Day }π IF N > 31 THENπ BEGINπ Mo := 4;π Da := N - 31π ENDπ ELSEπ BEGINπ Mo := 3;π Da := Nπ ENDπ END; { DateOfEaster }ππ{==========================================================================}ππ FUNCTION SIDateStr (y, m, d : WORD; SLen : BYTE; FillCh : CHAR) : STRING;ππ { Returns date <y>, <m>, <d> converted to a string in SI format. If }π { <Slen> = 10, the string is in form YYYY_MM_DD; If <SLen> = 8, in form }π { YY_MM_DD; otherwise a NULL string is returned. The character between }π { values is <FillCh>. }π { For correct Systeme-Internationale date format, the call should be: }π { SIDateStr (Year, Month, Day, 10, ' '); }π { IF <y>, <m> & <d> are all = 0, Runtime library PROCEDURE GetDate is }π { called to obtain the current date. }ππ VARπ s2 : STRING[2];π s4 : STRING[4];π DStr : STRING[10];π Index : BYTE;π dw : WORD;π BEGINπ IF (SLen <> 10) AND (SLen <> 8) THENπ DStr[0] := Chr (0)π ELSEπ BEGINπ IF (y = 0) AND (m = 0) AND (d = 0) THENπ GetDate (y, m, d, dw);π IF SLen = 10 THENπ BEGINπ Str (y:4, s4);π DStr[1] := s4[1];π DStr[2] := s4[2];π DStr[3] := s4[3];π DStr[4] := s4[4];π Index := 5π ENDπ ELSEπ IF SLen = 8 THENπ BEGINπ Str (y MOD 100:2, s2);π DStr[1] := s2[1];π DStr[2] := s2[2];π Index := 3π END;π DStr[Index] := FillCh;π Inc (Index);π Str (m:2, s2);π IF s2[1] = ' ' THENπ DStr[Index] := '0'π ELSEπ DStr[Index] := s2[1];π DStr[Index+1] := s2[2];π Index := Index + 2;π DStr[Index] := FillCh;π Inc (Index);π Str (d:2, s2);π IF s2[1] = ' ' THENπ DStr[Index] := '0'π ELSEπ DStr[Index] := s2[1];π DStr[Index+1] := s2[2];π DStr[0] := Chr (SLen)π END;π SIDateStr := DStrπ END; { SIDateStr }π π{==========================================================================}ππ FUNCTION TimeStr (h, m, s, c : WORD) : STRING;ππ { Returns the time <h>, <m>, <s> and <c> formatted in a string: }π { "HH:MM:SS.CC" }π { This function does NOT check for valid string length. }π { }π { IF <h>, <m>, <s> & <c> all = 0, the Runtime PROCEDURE GetTime is }π { called to get the current time. }ππ VARπ sh, sm, ss, sc : STRING[2];π BEGINπ IF h + m + s + c = 0 THENπ GetTime (h, m, s, c);π Str (h:2, sh);π IF sh[1] = ' ' THENπ sh[1] := '0';π Str (m:2, sm);π IF sm[1] = ' ' THENπ sm[1] := '0';π Str (s:2, ss);π IF ss[1] = ' ' THENπ ss[1] := '0';π Str (c:2, sc);π IF sc[1] = ' ' THENπ sc[1] := '0';π TimeStr := Concat (sh, ':', sm, ':', ss, '.', sc)π END; { TimeStr }ππ{==========================================================================}π FUNCTION TimeStr2 (h, m, s : WORD) : STRING;ππ { Returns the time <h>, <m>, and <s> formatted in a string: }π { "HH:MM:SS" }π { This function does NOT check for valid string length. }π { }π { IF <h>, <m>, & <c> all = 0, the Runtime PROCEDURE GetTime is }π { called to get the current time. }ππ VARπ c : word;π sh, sm, ss : STRING[2];π BEGINπ IF h + m + s = 0 THENπ GetTime (h, m, s, c);π Str (h:2, sh);π IF sh[1] = ' ' THENπ sh[1] := '0';π Str (m:2, sm);π IF sm[1] = ' ' THENπ sm[1] := '0';π Str (s:2, ss);π IF ss[1] = ' ' THENπ ss[1] := '0';π TimeStr2 := Concat (sh, ':', sm, ':', ss)π END; { TimeStr2 }ππ{==========================================================================}π FUNCTION MDYR_Str (y, m, d : WORD): STRING; {dwh}ππ { Returns the date <y>, <m>, <d> formatted in a string: }π { "MM/DD/YYYY" }π { This function does NOT check for valid string length. }π { }π { IF <m>, <d>, & <y> all = 0, the Runtime PROCEDURE GetDate is }π { called to get the current date. }ππ VARπ sm, sd : STRING[2];π sy : STRING[4];π dont_care : word;π BEGINπ IF y + m + d = 0 THENπ GetDate (y, m, d, dont_care);π Str (m:2, sm);π IF sm[1] = ' ' THENπ sm[1] := '0';π Str (d:2, sd);π IF sd[1] = ' ' THENπ sd[1] := '0';π Str (y:4, sy);π MDYR_Str := Concat (sm, '/', sd, '/', sy)π END; { MDYR_Str }πππ{==========================================================================}ππ FUNCTION Secs100 (h, m, s, c : WORD) : DOUBLE;ππ { Returns the given time <h>, <m>, <s> and <c> as a floating-point }π { value in seconds (presumably valid to .01 of a second). }π { }π { IF <h>, <m>, <s> & <c> all = 0, the Runtime PROCEDURE GetTime is }π { called to get the current time. }ππ BEGINπ IF h + m + s + c = 0 THENπ GetTime (h, m, s, c);π Secs100 := (h * 60.0 + m) * 60.0 + s + (c * 0.01)π END; { Secs100 }πππ{==========================================================================}ππ PROCEDURE AddDays (y, m, d : WORD; plus : LONGINT; VAR y1, m1, d1 : WORD);ππ { Computes the date <y1>, <m1>, <d1> resulting from the addition of }π { <plus> days to the calendar date <y>, <m>, <d>. }ππ VARπ JulDay : LONGINT;π BEGINπ JulDay := JulianDay (y, m, d) + plus;π JulianDayToDate (JulDay, y1, m1, d1)π END; { AddDays }ππ{==========================================================================}ππ FUNCTION ValidDate (y, m, d : WORD) : BOOLEAN;ππ { Returns TRUE if the date <y> <m> <d> is valid. }ππ VARπ JulDay : LONGINT;π ycal, mcal, dcal : WORD;π BEGINπ JulDay := JulianDay (y, m, d);π JulianDayToDate (JulDay, ycal, mcal, dcal);π ValidDate := (y = ycal) AND (m = mcal) AND (d = dcal)π END; { ValidDate }ππ{==========================================================================}ππ FUNCTION DayOfWeek (y, m, d : WORD) : WORD;ππ { Returns the Day-of-the-week (0 = Sunday) (Zeller's congruence) from an }π { algorithm IZLR given in a remark on CACM Algorithm 398. }ππ VARπ Tmp1, Tmp2, yy, mm, dd : LONGINT;π BEGINπ yy := y;π mm := m;π dd := d;π Tmp1 := mm + 10;π Tmp2 := yy + (mm - 14) DIV 12;π DayOfWeek := ((13 * (Tmp1 - Tmp1 DIV 13 * 12) - 1) DIV 5 +π dd + 77 + 5 * (Tmp2 - Tmp2 DIV 100 * 100) DIV 4 +π Tmp2 DIV 400 - Tmp2 DIV 100 * 2) MOD 7;π END; { DayOfWeek }ππ{==========================================================================}πFUNCTION DayOfWeek_Str (y, m, d : WORD) : String;πbeginπ CASE DayOfWeek (y, m, d) ofπ 0: DayOfWeek_Str := 'SUNDAY';π 1: DayOfWeek_Str := 'MONDAY';π 2: DayOfWeek_Str := 'TUESDAY';π 3: DayOfWeek_Str := 'WEDNESDAY';π 4: DayOfWeek_Str := 'THURSDAY';π 5: DayOfWeek_Str := 'FRIDAY';π 6: DayOfWeek_Str := 'SATURDAY';π end; {case}πend; {dayofweek_str}πππ{==========================================================================}πFUNCTION JJ_JulianDay (y, m, d : word) : LONGINT;π {* format 5 position = last 2 digits of year+DayOfYear *}πvarπ dw : word;πbeginπ IF (y+m+d = 0)π THEN GetDate (Y,M,D, dw);π JJ_JulianDay:= ((LongInt(y) Mod 100)*1000+ DayOfYear(y,m,d));πend; {jj_julianday}πππ{==========================================================================}πPROCEDURE JJ_JulianDayToDate (nd : LONGINT; VAR y, m, d : WORD);π {* format nd=5 positions last 2 digits of year+DayOfYear *}πBEGINπ y := (nd DIV 1000); {year}π IF (y < 60) {will error when 2060}π THEN y := 2000+yπ ELSE y := 1900+y;π {dayofyear}π DayOfYearToDate ( (nd MOD 1000), y, m, d);πEND; { JulianDayToDate }ππ{==========================================================================}πFUNCTION Lotus_Date_Str (nd : LONGINT) : string;π {* lotus is strange the ND is the number of days SINCE 12/31/1899 *}π {* which is the JULIAN day 2415020 *}π {* Return format is MM/DD/YYYY *}πvarπ y,m,d : word;πbeginπ JulianDayToDate (nd+2415020-1, y,m,d);π Lotus_Date_Str := MDYr_Str (y,m,d);πend; {lotus_date_str}ππ{==========================================================================}πFUNCTION Str_Date_to_Lotus_Date_Format( Date : String;π VAR Err_Msg : String): LongInt;{OLC}πVARπ Y, M, D : word;π Julian : LongInt;πBEGINπ Err_Msg := '';π IF ValidDate_Str(Date, Y, M, D, Err_Msg ) THENπ BEGINπ Julian := JulianDay( Y, M, D );π Julian := Julian - 2415020 + 1;π Str_Date_to_Lotus_Date_Format := Julianπ ENDπ ELSEπ Str_Date_to_Lotus_Date_Format := -1;πEND;{Str_Date_to_Lotus_Date_Format}πππ{==========================================================================}πFUNCTION ValidDate_Str (Str : string;π VAR Y, M, D : word;π VAR Err_Str : string) : boolean;π {* returns TRUE when Str is valid MM/DD/YYYY or MM-DD-YYYY *}π {* the values are ranged checked and the date is also *}π {* checked for existance *}π {* Y, M, D are filled in with the values. *}πvarπ Err_Code : integer;π Long_Int : LongInt;π Slash1, Slash2 : byte;πbeginπ Err_Str := '';π Err_Code := 0;ππ IF (Length (Str) < 8)π THEN Err_Str := 'Date must be 12/31/1999 format'π ELSEπ BEGINπ Slash1 := POS ('/', Str);π IF (Slash1 > 0)π THEN Slash2 := POS ('/', COPY (Str, Slash1+1, LENGTH(Str))) + Slash1π ELSEπ BEGINπ Slash2 := 0;π Slash1 := POS ('-', Str);π IF (Slash1 > 0)π THEN Slash2 := POS ('-', COPY (Str, Slash1+1,π LENGTH(Str))) + Slash1;π END;ππ IF ((Slash1 = Slash2) or (Slash2 = 0))π THEN Err_Str := 'Date String must have either "-" or "/"'+π ' such as (12/01/1999)'π ELSEπ BEGINπ VAL (COPY(Str, 1,(Slash1-1)), Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 12))π THEN Err_Str := 'Month must be a number 1..12!'ππ ELSEπ BEGINπ M := Long_Int;π VAL (COPY(Str, (Slash1+1),(Slash2-Slash1-1)),π Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 31))π THEN Err_Str := 'Day must be a number 1..31!'ππ ELSEπ BEGINπ D := Long_Int;π VAL (COPY(Str, (Slash2+1),LENGTH(Str)), Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 1900))π THEN Err_Str := 'Year must be a number greater than 1900!'π ELSE Y := Long_Int;π END;π END;π END;π END; {if long enough}ππ IF ((LENGTH(Err_Str) = 0) and (NOT DATES.ValidDate (Y, M, D)))π THEN Err_Str := 'Date does not exist!!!!';ππ IF (LENGTH(Err_Str) = 0)π THEN ValidDate_Str := TRUEπ ELSE ValidDate_Str := FALSE;ππEND; {validdate_str}ππ{==========================================================================}πFUNCTION ValidTime_Str (Str : string;π VAR H, M, S : word;π VAR Err_Str : string) : boolean;π {* returns TRUE when Str is valid HH:MM or HH:MM:SS *}π {* also H, M, S are filled in with the values. *}πvarπ Err_Code : integer;π Long_Int : LongInt;{use longint with VAL to prevent overflow}π Sep1, Sep2 : byte;π Count : byte;πbeginπ Err_Str := '';π Err_Code := 0;ππ IF (Length (Str) < 4)π THEN Err_Str := 'Time must be HH:MM or HH:MM:SS format'π ELSEπ BEGINπ Sep1 := POS (':', Str);π IF (Sep1 = 0)π THEN Err_Str := 'Time String must have either ":" '+π ' such as HH:MM or HH:MM:SS'ππ ELSEπ BEGINπ VAL (COPY(Str, 1,(Sep1-1)), Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 1) or (Long_Int > 24))π THEN Err_Str := 'Hour must be a number 1..24!'ππ ELSEπ BEGINπ H := Long_Int;π Sep2 := POS (':', COPY (Str, Sep1+1, LENGTH(Str))) + Sep1;π IF (Sep2 = Sep1)π THEN Count := LENGTH(Str)π ELSE Count := Sep2-Sep1-1;π VAL (COPY(Str,(Sep1+1),Count), Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 0) or (Long_Int > 59))π THEN Err_Str := 'Minute must be a number 0..59!'ππ ELSEπ BEGINπ M := Long_Int;π IF (Sep2 <> Sep1) THENπ BEGINπ VAL (COPY(Str, (Sep2+1),LENGTH(Str)), Long_Int, Err_Code);π IF ((Err_Code <> 0) or (Long_Int < 0) or (Long_Int > 59))π THEN Err_Str := 'Second must be a number 0..59!'π ELSE S := Long_Int;π ENDπ ELSE S := 0;π END;π END;π END;π END; {if long enough}ππ IF (LENGTH(Err_Str) = 0)π THEN ValidTime_Str := TRUEπ ELSE ValidTime_Str := FALSE;ππEND; {validtime_str}ππEND. {unit dates}ππ
